home *** CD-ROM | disk | FTP | other *** search
/ Atari Forever 4 / Atari Forever 4.zip / Atari Forever 4.iso / PD_THEMA / BIORHYTM / BIORHYTH.PD / TAG.PAS < prev    next >
Pascal/Delphi Source File  |  1998-03-14  |  2KB  |  61 lines
  1. var j,c,t,m : real;
  2.     system  : integer;
  3.     ende    : boolean;
  4. begin
  5. ende:=false;
  6. repeat
  7.   clrscr;writeln('Wochentagsermittlung (p)88 mkb');
  8.   writeln('------------------------------');writeln;
  9.   writeln('<- Bitte Jahr eingeben : ');write('..');
  10.     readln(c);
  11.   if c<0 then ende:=true;
  12.   if not ende then begin
  13.     writeln('<- Bitte Monat eingeben : ');write('..');
  14.     repeat
  15.       readln(m);
  16.     until (m>0) and (m<13); 
  17.     writeln('<- Bitte Tag eingeben : ');write('..');
  18.     repeat
  19.       readln(t);
  20.     until (t>0) and (t<32);writeln; 
  21.     j:=c-int(c/100)*100;
  22.     c:=(c-j)/100;
  23.     if m<3 then begin
  24.       m:=m+12;
  25.       j:=j-1;
  26.       if j<0 then begin
  27.         j:=99;
  28.         c:=c-1;
  29.       end;
  30.     end;
  31.     system:=0;
  32.     if c*100+j<1582 then system:=1 else
  33.     if c*100+j>1582 then system:=2 else
  34.     if m<10 then system:=1 else
  35.     if m>10 then system:=2 else
  36.     if t<5  then system:=1 else
  37.     if t>14 then system:=2;
  38.     case system of
  39.       0 : writeln(' -- Datum hat nicht existiert --');
  40.       1 : t:=t+int((m+1)*26/10)+j+int(j/4)+5-c;
  41.       2 : t:=t+int((m+1)*26/10)+j+int(j/4)+int(c/4)-2*c;
  42.     end;
  43.     t:=t-7*int(t/7);
  44.     repeat
  45.       if t>6 then t:=t-7;
  46.     until t<=7;
  47.     if (system>0) then 
  48.     case round(t) of
  49.       0 : writeln('-> Samstag');
  50.       1 : writeln('-> Sonntag');
  51.       2 : writeln('-> Montag');
  52.       3 : writeln('-> Dienstag');
  53.       4 : writeln('-> Mittwoch');
  54.       5 : writeln('-> Donnerstag');
  55.       6 : writeln('-> Freitag');
  56.     end;
  57.     j:=crawcin;
  58.   end;
  59. until ende;
  60. end.